home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 08 - 1992 / 08.03 Jul 92 / BigNums / bignums-object.sch < prev    next >
Encoding:
Text File  |  1990-06-03  |  7.7 KB  |  222 lines  |  [TEXT/EDIT]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:  bignums-object.sch ;
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;
  5. (define make-bignum-object
  6.   (lambda (internal-bignum . bases)
  7.     (make-bignum-result-object
  8.      (trampoline make-bignum
  9.                  (cons internal-bignum
  10.                        bases))
  11.      (to-base?? bases))))
  12. ;
  13. (define make-bignum-result-object
  14.   (lambda (user-bignum base)
  15.     (let ((type 'soft-bignum)
  16.           (the-remainder #f))
  17.       (lambda (message . args)
  18.         (cond ((eq? message 'get-base)
  19.                base)
  20.               ((eq? message 'change-base)
  21.                (begin
  22.                 (if 
  23.                  (or (bignum-zero? user-bignum)
  24.                      (bignum-=? user-bignum 
  25.                                 bignum-one))
  26.                  (set! base 'all)
  27.                  (begin 
  28.                   (set! user-bignum
  29.                         (bignum-base-n->bignum-base-m 
  30.                          user-bignum
  31.                          base
  32.                          (car args)))
  33.                   (set! base (car args))))
  34.                 base))
  35.               ((eq? message 'change-sign)
  36.                (begin 
  37.                 (set! user-bignum 
  38.                       (bignum-change-sign
  39.                        user-bignum))
  40.                 user-bignum))
  41.               ((eq? message 'get-type)
  42.                type)
  43.               ((eq? message 'get-number)
  44.                user-bignum)
  45.               ((eq? message 'show-number)
  46.                (show-bignum user-bignum))
  47.               ((eq? message 'get-remainder)
  48.                the-remainder)
  49.               ((eq? message 'show-remainder)
  50.                (show-bignum the-remainder))
  51.               ((eq? message 'set-remainder)
  52.                (set! the-remainder (car args)))
  53.               ((eq? message '?)
  54.                '(get-base change-base change-sign 
  55.                  get-type get-number show-number 
  56.                  get-remainder show-remainder
  57.                  set-remainder ?))
  58.               (else
  59.                (error "Bad message to bignum object." 
  60.                       message)))))))
  61. ;
  62. (define copy-bignum-object
  63.   (lambda (object)
  64.     (let ((result (make-bignum-result-object 
  65.                    (object 'get-number) 
  66.                    (object 'get-base))))
  67.       (begin
  68.        (result 'set-remainder (object 'get-remainder))
  69.        result))))
  70. ;
  71. ; Note:  Friends and associates of bignum-=? are left 
  72. ; to the reader to implement.  They all will look quite
  73. ; similar to the below.
  74. ;
  75. (define bignum-=?
  76.   (lambda (first second)
  77.     (let ((first-sign (get-sign first))
  78.           (second-sign (get-sign second)))
  79.       (if (and (eq? first-sign second-sign)
  80.                (big-=? (bignum-abs first)
  81.                        (bignum-abs second)))
  82.           #t
  83.           #f))))
  84. ; 
  85. (define make-objects-base-compatible
  86.   (lambda (object1 object2)
  87.     (let ((object1-base (object1 'get-base))
  88.           (object2-base (object2 'get-base)))
  89.       (if (or (eq? object1-base 'all)
  90.               (eq? object2-base 'all)
  91.               (=? object1-base object2-base))
  92.           (cons object1 object2)
  93.           (if (>? object1-base 
  94.                   object2-base)
  95.               (cons object1
  96.                     (let ((second-object 
  97.                            (copy-bignum-object 
  98.                             object2)))
  99.                       (second-object 'change-base 
  100.                                      object1-base)
  101.                       second-object))
  102.               (cons (let ((first-object 
  103.                            (copy-bignum-object 
  104.                             object1)))
  105.                       (first-object 'change-base 
  106.                                     object2-base)
  107.                       first-object)
  108.                     object2))))))
  109. ;
  110. (define find-common-base
  111.   (lambda (object1 object2)
  112.     (let ((object1-base (object1 'get-base))
  113.           (object2-base (object2 'get-base)))
  114.       (if (eq? object1-base 'all)
  115.           (if (eq? object2-base 'all)
  116.               10
  117.               object2-base)
  118.           (if (eq? object2-base 'all)
  119.               object1-base
  120.               (if (>? object1-base object2-base)
  121.                   object1-base
  122.                   object2-base))))))
  123. ;       
  124. (define bignum-object-div
  125.   (lambda (dividend divisor)
  126.     (let ((pair-of-objects (make-objects-base-compatible 
  127.                             dividend divisor)))
  128.       (let ((dividend (car pair-of-objects))
  129.             (divisor (cdr pair-of-objects)))
  130.         (let 
  131.           ((base (find-common-base dividend divisor)))
  132.           (let 
  133.             ((result (bignum-div (dividend 'get-number)
  134.                                  (divisor 'get-number)
  135.                                  base)))
  136.             (let ((the-quotient (first-digit result))
  137.                   (the-remainder (rest-digits result)))
  138.               (let ((return-value 
  139.                      (make-bignum-result-object 
  140.                       the-quotient base)))
  141.                 (begin (return-value 'set-remainder 
  142.                                      the-remainder)
  143.                        return-value)))))))))
  144. ;
  145. (define bignum-object-mul
  146.   (lambda (multiplicand multiplier)
  147.     (let ((pair-of-objects 
  148.            (make-objects-base-compatible multiplicand 
  149.                                          multiplier)))
  150.       (let ((multiplicand (car pair-of-objects))
  151.             (multiplier (cdr pair-of-objects)))
  152.         (let ((base (find-common-base multiplicand 
  153.                                       multiplier)))
  154.           (let ((result (bignum-mul (multiplicand 
  155.                                      'get-number)
  156.                                     (multiplier 
  157.                                      'get-number)
  158.                                     base)))
  159.             (make-bignum-result-object result 
  160.                                        base)))))))
  161. ;
  162. (define bignum-object-add
  163.   (lambda (addend augend)
  164.     (let ((pair-of-objects 
  165.            (make-objects-base-compatible addend 
  166.                                          augend)))
  167.       (let ((addend (car pair-of-objects))
  168.             (augend (cdr pair-of-objects)))
  169.         (let ((base (find-common-base addend augend)))
  170.           (let ((result (bignum-add 
  171.                          (addend 'get-number)
  172.                          (augend 'get-number)
  173.                          base)))
  174.             (make-bignum-result-object result 
  175.                                        base)))))))
  176. ;   
  177. (define bignum-object-sub
  178.   (lambda (minuend subtrahend)
  179.     (let ((pair-of-objects (make-objects-base-compatible 
  180.                             minuend subtrahend)))
  181.       (let ((minuend (car pair-of-objects))
  182.             (subtrahend (cdr pair-of-objects)))
  183.         (let ((base (find-common-base minuend 
  184.                                       subtrahend)))
  185.           (let ((result 
  186.                  (bignum-sub (minuend 'get-number)
  187.                              (subtrahend 'get-number)
  188.                              base)))
  189.             (make-bignum-result-object result 
  190.                                        base)))))))
  191. ;
  192. ; The below could be put into bignum object definition.
  193. ;
  194. (define bignum-object-base-n->bignum-object-base-m
  195.   (lambda (bignum-object from-base to-base)
  196.     (let ((result (bignum-base-n->bignum-base-m 
  197.                    (bignum-object 'get-number)
  198.                    from-base
  199.                    to-base)))
  200.       (make-bignum-result-object result to-base))))
  201. ;
  202. (define bignum-object-zero?
  203.   (lambda (candidate)
  204.     (bignum-zero? (candidate 'get-number))))
  205. ;
  206. (define bignum-object-zero
  207.   (make-bignum-object ()))
  208. ;
  209. (define bignum-object-one
  210.   (make-bignum-object '(1)))
  211. ;
  212. (define bignum-object-fact
  213.   (lambda (n)
  214.     (if (bignum-object-zero? n)
  215.         bignum-object-one
  216.         (bignum-object-mul 
  217.          n
  218.          (bignum-object-fact 
  219.           (bignum-object-sub n 
  220.                              bignum-object-one))))))
  221. ;             
  222. 'done